home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 6.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  38KB  |  1,256 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "libhdr.h"
  12. #include "vars.h"
  13. #include "setp.h"
  14. #include "dclmapp.h"
  15. #include "errmsgp.h"
  16. #include "miscp.h"
  17. #include "smiscp.h"
  18. #include "nodesp.h"
  19. #include "utilp.h"
  20. #include "chapp.h"
  21. #include "libp.h"
  22.  
  23. static void invisible_designator(Node, char *);
  24. static Tuple derived_formals(Symbol, Tuple);
  25. static void proc_or_entry(Node);
  26. static void new_over_spec(Symbol, int, Symbol, Tuple, Symbol, Node);
  27.  
  28. void subprog_decl(Node node)  /*;subprog_decl*/
  29. {
  30.     Node    spec_node, id_node, neq_node, eq_node;
  31.     Symbol    subp_name, neq;
  32.     int        exists;
  33.     Forset    fs1;
  34.  
  35.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  subprog_decl");
  36.  
  37.     spec_node = N_AST1(node);
  38.     id_node = N_AST1(spec_node);
  39.     new_compunit("ss", id_node);
  40.     adasem(spec_node);
  41.     check_spec(node);
  42.  
  43.     subp_name = N_UNQ(id_node);
  44.     save_subprog_info(subp_name);
  45.  
  46.     /* Modify the node kind for subprogram declarations to be 
  47.      * as_subprogram_decl_tr so that their specification part need not be 
  48.      * saved in the tree automatically. The formal part will be saved by 
  49.      * collect_unit_nodes only in the case of a subprogram specification 
  50.      * that is not in the same unit as the body as it is then needed for 
  51.      * conformance checks. In addition the node as_procedure (as_function)
  52.      * is no longer needed in the tree since this info is obtained from
  53.      * the symbol table.
  54.      * Since the spec  part is now dropped we now move the id_node info 
  55.      * (name of the subprogram) to the N_UNQ filed of the as_subprogram_decl_tr
  56.      * node directly.
  57.      */
  58.  
  59.     N_KIND(node) = as_subprogram_decl_tr;
  60.     N_UNQ(node) = N_UNQ(id_node);
  61.     if (streq(N_VAL(id_node) , "=") &&  tup_size(SIGNATURE(subp_name)) == 2) {
  62.         /* build tree for declaration of inequality that was just introduced 
  63.          * (in the current scope, or the enclosing one, if now in private part).
  64.          */
  65.         exists = FALSE;
  66.         FORSET(neq = (Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(subp_name)),
  67.           "/=")), fs1);
  68.             if ( same_signature(neq, subp_name) ) {
  69.                 exists = TRUE;
  70.                 break;
  71.             }
  72.         ENDFORSET(fs1);
  73.         if (exists) {
  74.             neq_node = copy_tree(node);          /* a valid subprogram decl*/
  75.             N_UNQ(neq_node) = neq;
  76.             eq_node = copy_node(node);
  77.             make_insert_node(node, tup_new1((char *) eq_node), neq_node);
  78.         }
  79.     }
  80. }
  81.  
  82. void check_spec(Node node) /*;check_spec*/
  83. {
  84.     /* If the subprogram name is an     operator designator, verify that it has
  85.      * the proper type and number of arguments.
  86.      */
  87.  
  88.     int        proc_nat;
  89.     Node    spec_node, id_node, formal_node, ret_node;
  90.     char    *proc_id;
  91.     Tuple    formals;
  92.     Symbol    ret;
  93.     Symbol    prog_name;
  94.     int        spec_kind, node_kind;
  95.  
  96.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_spec ");
  97.  
  98.     spec_node = N_AST1(node);
  99.     id_node = N_AST1(spec_node);
  100.     formal_node = N_AST2(spec_node);
  101.     ret_node = N_AST3(spec_node);
  102.     proc_id = N_VAL(id_node);
  103.  
  104.     spec_kind = N_KIND(spec_node);
  105.     if (spec_kind == as_procedure)
  106.         ret = symbol_none;
  107.     else
  108.         ret = N_UNQ(ret_node);
  109.  
  110.     switch (node_kind = N_KIND(node)) {
  111.       case    as_subprogram_decl:
  112.                 if (spec_kind == as_procedure)
  113.                     proc_nat = na_procedure_spec;
  114.                 else
  115.                     proc_nat = na_function_spec;
  116.                 break;
  117.       case    as_subprogram:
  118.       case    as_subprogram_stub:
  119.       case    as_generic_subp:
  120.                 if (spec_kind == as_procedure)
  121.                     proc_nat = na_procedure;
  122.                 else
  123.                     proc_nat = na_function;
  124.                 break;
  125.     }
  126.  
  127.     formals = get_formals(formal_node, proc_id);
  128.  
  129.     check_out_parameters(formals);
  130.  
  131.     if (in_op_designators(proc_id ))
  132.         check_new_op(id_node, formals, ret);
  133.  
  134.     prog_name = chain_overloads(proc_id, proc_nat, ret, formals, (Symbol)0,
  135.       formal_node);
  136.     N_UNQ(id_node) = prog_name;
  137. }
  138.  
  139. void check_new_op(Node id_node, Tuple formals, Symbol ret)    /*;check_new_op */
  140. {
  141.     /* apply special checks for definition of operators */
  142.     char *proc_id;
  143.     Tuple tup;
  144.     Fortup ft1;
  145.     Node  initv;
  146.     int  exists;
  147.     Symbol typ1;
  148.  
  149.     proc_id = N_VAL(id_node);
  150.  
  151.     if ((strcmp(proc_id , "+") == 0 || strcmp(proc_id, "-") == 0)
  152.       && tup_size(formals) == 1)
  153.         ;    /* Unary operators.*/
  154.     else if ( (strcmp(proc_id , "not") == 0 || strcmp(proc_id, "abs") == 0)
  155.       ? tup_size(formals) == 1 : tup_size(formals) == 2 )
  156.         ;
  157.     else {
  158.         errmsg_str("Incorrect no. of arguments for operator %" , proc_id,
  159.           "6.7", id_node);
  160.     }
  161.  
  162.     exists = FALSE;
  163.     FORTUP(tup = (Tuple), formals, ft1);
  164.         initv = (Node)tup[4];
  165.         if (initv != OPT_NODE) {
  166.             exists = TRUE;
  167.             break;
  168.         }
  169.     ENDFORTUP(ft1);
  170.     if (exists) {
  171.         errmsg("Initializations not allowed for operators", "6.7", initv);
  172.     }
  173.     /* Apply the special checks on redefinitions of equality.*/
  174.     else if (streq(proc_id , "=")) {
  175.         typ1 = (Symbol) ((Tuple)formals[1])[3];    /* type of formal*/
  176.         if (tup_size(formals) != 2
  177.           || typ1 != (Symbol) ((Tuple)formals[2])[3] 
  178.           || ret != symbol_boolean) {
  179.             errmsg("Invalid argument profile for \"=\"", "6.7", id_node);
  180.         }
  181.     }
  182.     else if (strcmp(proc_id , "/=") == 0) {
  183.         errmsg(" /=     cannot be given an explicit definition", "6.7", id_node);
  184.     }
  185. } /* end check_new_op */
  186.  
  187. Tuple get_formals(Node formal_list, char *proc_id)             /*;get_formals*/
  188. {
  189.     /* Utility to format the formals of a subprogram specification, in the
  190.      * internal form kept in  the subprogram's signature.
  191.      */
  192.  
  193.     Node    formal_node, id_list, m_node, type_node, exp_node, id_node;
  194.     Tuple    formals, tup;
  195.     Fortup    ft1, ft2;
  196.     int        formal_index, f_mode;
  197.     Symbol     type_mark;
  198.  
  199.     formal_index = 0;
  200.     FORTUP(formal_node = (Node), N_LIST(formal_list), ft1);
  201.         id_list = N_AST1(formal_node);
  202.         FORTUP(id_node = (Node), N_LIST(id_list), ft2);
  203.             formal_index++;
  204.         ENDFORTUP(ft2);
  205.     ENDFORTUP(ft1);
  206.     formals = tup_new(formal_index);
  207.     formal_index = 0;
  208.  
  209.     FORTUP(formal_node = (Node), N_LIST(formal_list), ft1);
  210.         id_list = N_AST1(formal_node);
  211.         m_node = N_AST2(formal_node);
  212.         type_node = N_AST3(formal_node);
  213.         invisible_designator(type_node, proc_id);
  214.         exp_node = N_AST4(formal_node);
  215.         invisible_designator(exp_node, proc_id);
  216.         f_mode = (int) N_VAL(m_node);
  217.         if (f_mode == 0) f_mode = na_in; /* note using 0 for '' f_mode case */
  218.         type_mark = find_type(copy_tree(type_node)); /* for conformance check */
  219.         FORTUP(id_node = (Node), N_LIST(id_list), ft2);
  220.             formal_index++;
  221.             tup = tup_new(4);
  222.             tup[1] = (char *)N_VAL(id_node);
  223.             tup[2] = (char *) f_mode;
  224.             tup[3] = (char *) type_mark;
  225.             tup[4] = (char *) copy_tree(exp_node);
  226.             formals[formal_index] = (char *) tup;
  227.         ENDFORTUP(ft2);
  228.     ENDFORTUP(ft1);
  229.  
  230.     return (formals);
  231. }
  232.  
  233. static void invisible_designator(Node tree_node, char *proc_id)
  234. /*;invisible_designator*/
  235. {
  236.     /*
  237.      * check for premature use of formals
  238.      */
  239.  
  240.     int        nk;
  241.     Node    n;
  242.     Fortup    ft1;
  243.  
  244.     /* The designator of a subprogram is not visible within its specification.*/
  245.  
  246.     nk = N_KIND(tree_node);
  247.     if (N_KIND(tree_node) == as_simple_name)  {
  248.         if (streq(N_VAL(tree_node), proc_id))
  249.             errmsg_str("premature usage of %", proc_id, "8.3(16)", tree_node);
  250.     }
  251.     else {
  252.         if (N_AST1_DEFINED(nk)) invisible_designator(N_AST1(tree_node),proc_id);
  253.         if (N_AST2_DEFINED(nk)) invisible_designator(N_AST2(tree_node),proc_id);
  254.         if (N_AST3_DEFINED(nk)) invisible_designator(N_AST3(tree_node),proc_id);
  255.         if (N_AST4_DEFINED(nk)) invisible_designator(N_AST4(tree_node),proc_id);
  256.  
  257.         if (N_LIST_DEFINED(nk) && N_LIST(tree_node) != (Tuple)0) {
  258.             FORTUP(n = (Node), N_LIST(tree_node), ft1);
  259.                 invisible_designator(n, proc_id);
  260.             ENDFORTUP(ft1);
  261.         }
  262.     }
  263. }
  264.  
  265. void subprog_body(Node node)        /*;subprog_body*/
  266. {
  267.     Node    specs_node, id_node, stats_node;
  268.     Node    eq_node, neq_node;
  269.     char    *spec_name, *prog_id;
  270.     Symbol    unname, prog_name, neq, scope;
  271.     int        i;
  272.     Forset    fs1;
  273.     Fortup    ft1;
  274.     int        exists;
  275.     Tuple    decscopes, decmaps, s_info;
  276.     /* s_info may not be needed     ds 30 jul*/
  277.     Unitdecl    ud;
  278.  
  279.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : subprog_body");
  280.  
  281.     specs_node  = N_AST1(node);
  282.  
  283.     id_node = N_AST1(specs_node);
  284.     adasem(id_node);
  285.     prog_id = N_VAL(id_node);
  286.  
  287.     if (IS_COMP_UNIT) {
  288.         new_compunit("su", id_node);
  289.         /* If the specification of the unit was itself a compilation unit, we
  290.          * will verify that the two specs are conforming. If this is the
  291.          * body to a generic comp. unit, will have to access and update the
  292.          * spec. In both c